COMMENT ⊗   VALID 00006 PAGES 
RECORD PAGE   DESCRIPTION
 00001 00001
 00002 00002	ENTRY SNDPIC
 00005 00003	INTEGER CHN
 00008 00004	INTERNAL PROCEDURE PICTOSEG(PICTURE PICINTEGER SEGNAMSTRING TITLE)
 00013 00005	INTERNAL PROCEDURE DDCALL(PICTURE PICSTRING TITLE,COMS)
 00017 00006	INTERNAL STRING PROCEDURE RECPIC(PICTURE PICINTEGER MODESTRING FILE)
 00020 ENDMK
⊗;
ENTRY SNDPIC;
BEGIN"PICIO"
REQUIRE "PROLOG.HDR[1,PDQ]" SOURCE_FILE;
REQUIRE "COMSUB.HDR[1,PDQ]" SOURCE_FILE;


INTEGER BCLIP,TCLIP,BITS,IWID,LINLEN,FLINE,LLINE,LSIDE,RSIDE,SIZE,TVWORD;

INTERNAL STRING GLBNAM; ⊃ GLOBAL FILE NAME FOR THE * OPTION;
INTERNAL SIMPROC QTOHE(PICTURE PIC);
⊃  Conversion  from  Quam  format  picture  header  array to hand-eye
library style parameters;
BEGIN	IWID←PIC[SIZEX];FLINE←PIC[POSY];LSIDE←PIC[POSX];
	RSIDE←LSIDE+IWID-1;LLINE←FLINE+PIC[SIZEY]-1;
	LINLEN←PIC[SIZEL];BITS←PIC[BIT];SIZE←LINLEN*PIC[SIZEY];
	BCLIP←PIC[OFFSET];TCLIP←PIC[GAIN];
END "QTOHE";


INTERNAL SIMPROC HETOQ(PICTURE PIC);
⊃  Conversion from hand-eye library parameters to Quam format picture
header array;
BEGIN	PIC[SCALEX]←PIC[SCALEY]←1;
	PIC[POSX]←LSIDE;PIC[POSY]←FLINE;
	PIC[SIZEX]←RSIDE-LSIDE+1;PIC[SIZEY]←LLINE-FLINE+1;
	PIC[SIZEL]←HAT(PIC[SIZEX],36 DIV BITS);
	PIC[BIT]←BITS;
	IF ABS(TCLIP)≤30 THEN BEGIN PIC[GAIN]←0;PIC[OFFSET]←0;END
	 ELSE BEGIN PIC[GAIN]←TCLIP;PIC[OFFSET]←BCLIP;END;
END "HETOQ";

DEFINE SNAM="'13",LNAM="'14";

INTEGER SIMPROC LEFT(INTEGER WD);
 START_CODE HLRE 1,WD;END;

INTEGER CHN;
PROCEDURE DSKLD(INTEGER DADR,ADR);
BEGIN	INTEGER BLK,WD;DEFINE BLKSIZ="'200";
	INTEGER ARRAY TEMP[0:BLKSIZ];
	BLK←DADR DIV BLKSIZ;WD←DADR MOD BLKSIZ;
	USETI(CHN,BLK+1);IF WD>0 THEN ARRYIN(CHN,TEMP[0],WD);
 START_CODE
	DEFINE P="'17";
	MOVE 1,ADR;HRRZ 2,-1(1);
	PUSH P,CHN;PUSH P,1;PUSH P,2;
	PUSHJ P,ARRYIN;
 END;
END "DSKLD";

STRING PROCEDURE STRLD(INTEGER IOWD);
 BEGIN	INTEGER WDS,DADR;
	IF (WDS←-LEFT(IOWD))≤0 THEN RETURN(NULL);
	DADR←IOWD LAND '777777;
	BEGIN INTEGER_ARRAY SBUF[1:WDS];
		DSKLD(DADR,LOC(SBUF[1]));
		RETURN(MAKSTR(SBUF[1],5*WDS));
	END;
END;

INTERNAL INTEGER SIMPROC STRIOWD(STRING S;REFERENCE INTEGER SLOC);
BEGIN	INTEGER SLNG,SWDS,WD;
	SLNG←LENGTH(S);SWDS←HAT(SLNG,5);
	WD←XWD(-SWDS,SLOC);SLOC←SLOC+SWDS;
	RETURN(WD);
END;


INTERNAL PROCEDURE STRFIL(STRING STR;PROCEDURE OUTER);
BEGIN	INTEGER STRWDS,STRLNG;STRWDS←HAT("STRLNG←LENGTH(STR)",5);
	IF STRWDS=0 THEN RETURN;
 BEGIN	INTEGER ARRAY SBUF[1:STRWDS];
	UNSTR(STR,POINT(7,SBUF[1],-1),STRLNG);
	OUTER(LOC(SBUF[1]));
 END;
END;

INTERNAL INTEGER SIMPROC PARGET(PICTURE PIC;INTEGER_ARRAY HEADER);
BEGIN	INTEGER I;
	BITS←HEADER[1];ARRBLT(LINLEN,HEADER[2],5);
	BCLIP←HEADER['40];TCLIP←HEADER['41];
	HETOQ(PIC);
	FOR I←7 STEP 1 UNTIL 14 DO
	 IF HEADER[I]≠0 THEN RETURN(HEADER[I] LAND '777777);
	OUTSTR("ILLEGAL PICTURE FORMAT"&CRLF);
END;

INTERNAL INTEGER PROCEDURE GETPARS(PICTURE PIC;INTEGER CHAN);
  IF (BCLIP←WORDIN(CHN←CHAN))≠-1 THEN
   BEGIN
	ARRYIN(CHN,TCLIP,9);				⊃ Input picture parameters;
	HETOQ(PIC);
	RETURN(10);
   END ELSE
   BEGIN
	INTEGER_ARRAY HEADER[1:'177];
	INTEGER LOC;
	ARRYIN(CHN,HEADER[1],'177);
	LOC←PARGET(PIC,HEADER);
	SETNAM(PIC,STRLD(HEADER[SNAM]));
	SETITLE(PIC,STRLD(HEADER[LNAM]));
	RETURN(LOC);
END "GETPARS";
INTERNAL PROCEDURE PICTOSEG(PICTURE PIC;INTEGER SEGNAM;STRING TITLE);
⊃  Transfers  the  picture  described  by  PIC to a 2nd segment whose
SIXBIT name is SEGNAM;
BEGIN
INTEGER SLOC,SGNAM;
SIMPROC SEGFIL(REFERENCE INTEGER ADR);
	SLOC←SLOC+ATOSEG(SGNAM,ADR,SLOC);

STRING TITLE,NAM;
TITLE←GETITLE(PIC);
SGNAM←SEGNAM;
NAM←GETNAM(PIC);
BEGIN	INTEGER ARRAY HEADER[0:31];
	INTEGER TEMP;
	ARRBLT(HEADER[0],PIC[0],PICMAX+1);
	SLOC←'400000+32;
	HEADER[PICMAX+1]←STRIOWD(NAM,SLOC);
	HEADER[PICMAX+2]←STRIOWD(TITLE,SLOC);
	SLOC←'400000;
	TEMP←LOC(HEADER[0]);
	SEGFIL(TEMP);		⊃ Transfer the header parameters;
	STRFIL(NAM,SEGFIL);
	STRFIL(TITLE,SEGFIL);
END;
IF PIC[PTR] THEN
	SEGFIL(PIC[PTR]);	⊃ Transfer the picture;
END "PICTOSEG";

INTERNAL STRING PROCEDURE SEGTOPIC(PICTURE PIC;INTEGER SEGNAM;BOOLEAN KILL);
⊃  Transfers  the  picture  from the 2nd segment whose SIXBIT name is
SEGNAM to picture header PIC.  The 2nd segment is killed if  KILL  is
true.  Returns the name of the 2nd segment;
BEGIN	INTEGER ARRAY HEADER[0:31];
	INTEGER SLOC,NLNG,NLNGS,TLNG,TLNGS;
	BOOLEAN FLG;
	STRING NAM,TITLE;
	PICREL(PIC);
	FLG←SEGTOA(SEGNAM,LOC(HEADER[0]),SLOC←'400000);		⊃ Get the header parameters;
	IF ¬FLG THEN BEGIN USERERR(0,1,CVXSTR(SEGNAM)&" NON-EX SEGMENT NAME ");
				RETURN(NULL);END;
	ARRBLT(PIC[0],HEADER[0],PICMAX+1);
	PIC[NAME]←0;
	TLNG←-LEFT(HEADER[PICMAX+2]);
	NLNG←-LEFT(HEADER[PICMAX+1]);
	SLOC←SLOC+32;
	IF TLNG+NLNG>0 THEN
	BEGIN INTEGER ARRAY SBLK[1:TLNG+NLNG];
		SEGTOA(SEGNAM,LOC(SBLK[1]),SLOC);
		NAM←MAKSTR(SBLK[1],5*NLNG);
		TITLE←MAKSTR(SBLK[1+NLNG],5*TLNG);
	END;
	SETNAM(PIC,NAM);SETITLE(PIC,TITLE);
	PIC[PTR]←0;PICMAK(PIC);				⊃ Allocate array space;
	IF PIC[PTR] THEN
		SEGTOA(SEGNAM,PIC[PTR],SLOC←SLOC+TLNG+NLNG);	⊃ Get the picture;
	IF KILL THEN KILSEG(SEGNAM);			⊃ And if KILL=TRUE kill the 2nd segment;
	RETURN(NAM);				⊃ And return the NAM of the segment;
END "SEGTOPIC";

INTERNAL STRING PROCEDURE PICPARS(PICTURE PIC;STRING NAM);
BEGIN	
	INTEGER PICCHN;BOOLEAN FLG;
	STRING EXT,PPN,NAM2;
	LABEL FOUND;
	OPEN(PICCHN←GETCHAN,"DSK",'10,1,0,0,0,0);
	FOR EXT←NULL,".TMP",".DAT" DO
	 FOR PPN←NULL,"[1,PDQ]","[M71,RBT]","[1,BO]","[001,MJH]" DO
	  BEGIN LOOKUP(PICCHN,NAM2←NAM&EXT&PPN,FLG);
		IF ¬FLG THEN BEGIN NAM←NAM2;GO TO FOUND;END;
	  END;
	WHILE FLG DO BEGIN NAM←STRIN(NAM&" NOT FOUND, FILE←");
			   LOOKUP(PICCHN,NAM,FLG);
		     END;
FOUND:	SETBREAK(1,".[",NULL,"INS");NAM2←NAM;
	IF GETPARS(PIC,PICCHN)=10 THEN 
	 BEGIN SETNAM(PIC,SCAN(NAM2,1,0));SETITLE(PIC,NAM);END;
	RELEASE(PICCHN);
	RETURN(NAM);
END "PICPARS";

INTERNAL PROCEDURE PICFORM(STRING PICNAM;REFERENCE INTEGER PPL,LINES);
BEGIN	INTEGER C;C←LOP(PICNAM);
	IF C="6"∨C="7" THEN BEGIN PPL←974;LINES←775;END
	 ELSE BEGIN PPL←832;LINES←700;END;
END;



INTERNAL PROCEDURE DDCALL(PICTURE PIC;STRING TITLE,COMS);
BEGIN	SAFE_OWN INTEGER ARRAY PARS[1:14];
	INTEGER ARRAY LETTER[1:32];
	INTEGER NO;
⊃	REQUIRE "SWAPER[1,PDQ]" LOAD_MODULE;
⊃	EXTERNAL STRING PROCEDURE JOBCALL(STRING SAVEJOB,CALLJOB;⊃ INTEGER ARRAY PARS);
	WHILE SEGXISTS(PARS[1]←CVSIX("DDPIC")) DO WAIT(1);
	PICTOSEG(PIC,PARS[1],TITLE);
	UNSTR("iDDPIC"&CRLF&COMS&CRLF&"R"&CRLF,POINT(7,LETTER[1],-1),5*32);
	IF (NO←JOBNUMBER("DDVID"))=0 THEN BEGIN OUTSTR("NO DDVID"&CRLF);RETURN;END;
	IF CANMAIL(NO) THEN SNDMAIL(LETTER,NO)
	  ELSE	OUTSTR("DDVID BUSY"&CRLF);
⊃	JOBCALL("DDSAV.RPG","DDSUB[1,PDQ]",PARS);
END "DDCALL";

INTERNAL PROCEDURE SNDPIC(PICTURE PIC;STRING TITLE,DEST);

⊃ This is the general purpose picture output  procedure,  which  will
transfer  a  picture to any of three different destinations specified
by the parameter  DEST.   DEST=@<FOO> specifies  the  Data  Disk  video
synthesizer.
Other non-NULL values of DEST specify a disk file. TITLE is a  string
describing  the  picture,  which the display programs output with the
picture.  PIC is or course the picture header array;

BEGIN
IF DEST="@" THEN DDCALL(PIC,TITLE,DEST[2 TO ∞])
ELSE IF DEST THEN				⊃ Otherwise, output picture to a disk file;
 BEGIN	INTEGER CHN,ADR,SLOC;			⊃ in hand-eye library format;
	INTEGER ARRAY HDR[0:'177];
	INTEGER TEMP,FLG;
	STRING NAM;
	SIMPROC DSKFIL(REFERENCE INTEGER A);
		START_CODE
		 DEFINE P="'17";
		 MOVE 1,A;HRRZ 2,-1(1);
		 ADDM 2,SLOC;
		 PUSH P,CHN;PUSH P,1;PUSH P,2;PUSHJ P,ARRYOUT;
		END;

	QTOHE(PIC);
	OPEN(CHN←GETCHAN,"DSK",'10,0,11,0,0,0);
	IF DEST="*" THEN DEST←GLBNAM&DEST[2 TO ∞];
	WHILE TRUE DO
		BEGIN ENTER(CHN,DEST,FLG);
			IF ¬FLG THEN DONE;
			DEST←STRIN(DEST&" ILLEGAL FILE NAME, FILE←");
		END;
	HDR[0]←-1;HDR[1]←BITS;ARRBLT(HDR[2],LINLEN,5);
	NAM←GETNAM(PIC);TITLE←GETITLE(PIC);
	SLOC←'200;
	HDR[SNAM]←STRIOWD(NAM,SLOC);HDR[LNAM]←STRIOWD(TITLE,SLOC);
	HDR[7]←XWD(-PIC[SIZEL]*PIC[SIZEY],SLOC);
	HDR['40]←PIC[OFFSET];HDR['41]←PIC[GAIN];
	SLOC←0;
	TEMP←LOC(HDR[0]);
	DSKFIL(TEMP);
	STRFIL(NAM,DSKFIL);
	STRFIL(TITLE,DSKFIL);
	DSKFIL(PIC[PTR]);
	RELEASE(CHN);
 END;
END "SNDPIC";

INTERNAL STRING PROCEDURE RECPIC(PICTURE PIC;INTEGER MODE;STRING FILE);

⊃ This is the general purpose picture input program which can receive
pictures from two different sources.  If FILE=@ then RECPIC will wait
for mail specifying a 2nd segment containing a picture to input.   If
MODE=0  then  RECPIC will restart the calling job on the next call to
RECPIC. If FILE≠@ then RECPIC will input a  hand-eye  library  format
picture  file.  PIC  is  of course the picture header array where the
picture is put. RECPIC returns the title of the picture if  there  is
one, otherwise FILE;

BEGIN
STRING TITLE;

INTEGER FLG,ADR,EOF,I,PST;LABEL L;
  PICREL(PIC);
  OPEN(CHN←GETCHAN,"DSK",'10,2,0,0,0,EOF);
  IF FILE="*" THEN FILE←GLBNAM&FILE[2 TO ∞];
L:LOOKUP(CHN,FILE,FLG);
  IF FLG THEN BEGIN FILE←STRIN("FILE=");GO TO L;END;
  PST←GETPARS(PIC,CHN);
  PICMAK(PIC);DSKLD(PST,PIC[PTR]);
  
  IF PST=10 THEN
   BEGIN
	INTEGER_ARRAY MESS[1:32];
	FOR I←5 STEP 1 UNTIL 32 DO
	 BEGIN MESS[I]←WORDIN(CHN);IF EOF∨MESS[I]=0 THEN DONE;END;	⊃ Input TITLE;
	SETNAM(PIC,TITLE←MKSTR(MESS,5));
   END ELSE TITLE←GETNAM(PIC);
RELEASE(CHN);
IF PIC[GAIN]=0 THEN PIC[GAIN]←PSCALE;
RETURN(IF TITLE THEN TITLE ELSE FILE);				⊃ If no TITLE, return FILE name;
END "RECPIC";

END "PICIO";